home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / HELP language 1.4 / Help Files / Compilation / Comp next >
Encoding:
Text File  |  1992-12-28  |  26.3 KB  |  745 lines  |  [TEXT/Help]
  1. {••• A 680x0 symbolic compiler for Help; An example of the code     •••}
  2. {•••  generated for fibonnacci is in the Folder "Foreign Code"      •••}
  3. {••• has been hand translated to MPW Asm, try by loading "Fib-Init" •••}
  4.  
  5. (define (compile-expression exp f-env rbut cont mode)
  6.     (cond (constante? exp)
  7.            (compile-constant exp f-env rbut cont mode)
  8.           (variable? exp)
  9.            (compile-acces-variable exp f-env rbut cont mode)
  10.           (definition? exp)
  11.            (compile-definition exp f-env rbut cont mode)
  12.           (affectation? exp)
  13.            (compile-affectation exp f-env rbut cont mode)
  14.           (begin? exp)
  15.            (compile-begin exp f-env rbut cont mode)
  16.           (lambda? exp)
  17.            (compile-lambda exp f-env rbut cont mode)
  18.           (cond? exp)
  19.            (compile-cond exp f-env rbut cont mode)
  20.           (bindings? exp)
  21.            (compile-bindings exp f-env rbut cont mode)
  22.           (nomemo? exp)
  23.            (compile-nomemo exp f-env rbut cont mode)
  24.           (warn? exp)
  25.            (compile-warn exp f-env rbut cont mode)
  26.           (step-call? exp)
  27.            (compile-step exp f-env rbut cont mode)
  28.           (let? exp)
  29.            (compile-let exp f-env rbut cont mode)
  30.           (rec? exp)
  31.            (compile-rec exp f-env rbut cont mode)
  32.           (macro-exp? exp)
  33.            (compile-macro exp f-env rbut cont mode)
  34.           (ss-args? exp)
  35.            (compile-ss-args exp f-env rbut cont mode)
  36.           (application? exp)
  37.            (compile-application exp f-env rbut cont mode)
  38.           (error '?:syntx-er exp)))
  39.  
  40. ;;; a step? function for debugging
  41. (define (step? f e)
  42.   (not (or (number? f)
  43.            (constant? f)
  44.            (and (cons? f)(macro? (0 f))))))
  45.  
  46. (prinlength 1000)
  47. (prindepth 1000)
  48.  
  49. ;;; compile e at the top level: lexical environments are accessed
  50. ;;; lexically (slight optimisation)
  51.  
  52. (define (cg e)
  53.     (compile-expression e '() 'R0 'return default-mode))
  54.  
  55. ;;; compile e in an UNKNOWN environment/ The environment is accessed
  56. ;;; at run time ! No lexical env. code generated
  57.  
  58. (define (cu e)
  59.     (compile-expression e '? 'R0 'return default-mode))
  60.  
  61. ;••• MODES •••
  62.  
  63. (define default-mode %000)
  64. (define nomemo-mode %100)
  65. (define step-mode %010)
  66. (define warn-mode %001)
  67.  
  68. (define (+mode am mode)
  69.   (bitor! am (bcopy mode)))
  70.  
  71. (define (-mode am mode)
  72.   (bitand! (bitnot! (bcopy am))(bcopy mode)))
  73.  
  74. ;••• CONTINUATION •••
  75.  
  76. (define (compile-cont  cont)
  77.   (cond 
  78.    (eq? cont 'next) (empty-pthunk)
  79.    (eq? cont 'return) (synt-rts)
  80.    (synt-bra cont)))
  81.  
  82. ;••• CONSTANTES •••
  83. (define (valeur k)
  84.   (eval k ()))
  85.  
  86. (define (every p l)
  87.   (cond (null? l) †
  88.         (p (0 l)) (every p (-1 l))))
  89.  
  90. (define (constante-simple? x)
  91.     (or (number? x)
  92.         (bitarray? x)
  93.         (cell? x)
  94.         (string? x)
  95.         (closure? x)
  96.         (environment? x)
  97.         (constant? x)
  98.         (quotee? x)))
  99.  
  100. (define (quotee? x)
  101.     (and (cons? x)
  102.          (eq? (0 x) 'quote)))
  103.  
  104. {(define (constante? x)
  105.   (or (constante-simple? x)
  106.       (and (cons? x) (every constante? x))))}
  107.  
  108. (define constante? constante-simple?)
  109.  
  110. (define (compile-constant k f-env rbut cont mode)
  111.     (add-source (append2pth (cond rbut (synt-move "L" (data (valeur k)) rbut)
  112.                                      (empty-pthunk))
  113.                             (compile-cont cont))
  114.                 (cons k f-env)))
  115.  
  116. ;••• Define •••
  117.  
  118. (define (definition? x)
  119.   (and (cons? x)
  120.        (eq? (0 x) 'define)))
  121.  
  122. (define (compile-definition exp f-env rbut cont mode)
  123.   (let [(exp2 (vardef2def (-1 exp)))]
  124.   (add-source
  125.       (appendpths
  126.              (compile-expression (1 exp2) f-env 'r0 'next mode)
  127.              (compile-glob-write (0 exp2) rbut cont))
  128.        (cons exp f-env))))
  129.  
  130. (define (vardef2def exp)
  131.   (cond (ident? (0 exp)) exp
  132.         (constant? (0 exp)) exp
  133.         (cons? (0 exp)) (list (0 (0 exp)) (cons 'lambda (cons (-1 (0 exp)) (-1 exp))))
  134.         (error '?:syntx-er exp)))
  135.  
  136. ;••• Variable •••
  137.  
  138. (define (variable? x)
  139.     (and (symbol? x)
  140.          (not (constant? x))))
  141.  
  142. ;si l'environnemnt est non défini, l'accès aux variables sera non lexical
  143. ;sinon, optimisation et accès via adresses lexicales
  144. ;si la valeur n'a pas de but - on ne compile que la continuation
  145. ;TBD: ceci est il en accord avec la sémantique de Help-Unau (forçage=>effets de bords possibles) ?
  146.  
  147. (define (compile-acces-variable v f-env rbut cont mode)
  148.   (append2pth
  149.       (add-strict (getlex v f-env))            ;this is Help-Unau !!!
  150.       (cond rbut
  151.         (compile-av-opt v f-env rbut cont mode)
  152.         (compile-cont cont))))
  153.  
  154. (define (compile-av-opt  v f-env rbut cont mode)
  155.     (let [(la (calcule-lex-address v f-env))]
  156.          (add-source (cond (error? la)(compile-lookup v rbut cont)
  157.                            (null? la) (append2pth (compile-glob-lookup v rbut)
  158.                                                   (compile-cont cont))
  159.                            (append2pth (compile-lex-lookup la rbut)
  160.                                        (compile-cont cont)))
  161.                      (cons v f-env))))
  162.  
  163. (define (compile-lookup v rbut cont)
  164.   (append2pth (synt-move "L" (data v) 'r0)
  165.               (cond (and (eq? rbut 'r0) (eq? cont 'return))
  166.                      (synt-callo thunk:lookvarval)
  167.                      (append2pth (synt-call thunk:lookvarval)
  168.                                  (synt-move "L" 'r0 rbut)))))
  169.  
  170. (define (compile-glob-lookup v rbut)
  171.   (append2pth (synt-move "L" (data v) 'r0)
  172.               (synt-move "L" '(4 r0) rbut)))
  173.  
  174. (define (compile-lex-lookup la rbut)
  175.   (cond (zero? (0 la)) (synt-move "L" `(,(+ 8 (* 4 (-1 la))) r2) rbut)
  176.         (appendpths (synt-move "L" '(4 r2) 'a1)
  177.                     (compile-frame-offset (1- (0 la)))
  178.                     (synt-move "L" `(,(+ 8 (* 4 (-1 la))) a1) rbut))))
  179.  
  180. (define (compile-frame-offset fo)
  181.   (cond (zero? fo) (empty-pthunk)
  182.         (append2pth (synt-move "L" '(4 A1) 'A1)
  183.                     (compile-frame-offset (1- fo)))))
  184.  
  185. (define (comp-force rf)
  186.   (let [(laf (cree-label "after-hold"))]
  187.        (appendpths (synt-btst 2 `(-4 ,rf))
  188.                    (synt-beq laf)
  189.                    (cond (eq? rf 'r0)(synt-call thunk:holdr0)
  190.                          (eq? rf 'a0)(synt-call thunk:holda0)
  191.                          (eq? rf 'a1)(synt-call thunk:holda1)
  192.                          (appendpths (synt-move "L" rf 'R0)
  193.                                      (synt-call thunk:holdr0)
  194.                                      (synt-move "L" 'r0 rf)))
  195.                    (synt-label laf))))
  196.  
  197.  ;••• affectation •••
  198.  
  199. (define (affectation? exp)
  200.   (and (cons? exp) (eq? (0 exp) '=!)))
  201.  
  202. (define (compile-affectation exp f-env rbut cont mode)
  203.   (let    [(la (calcule-lex-address (1 exp) f-env))
  204.            (t (compile-expression (2 exp) f-env 'r0 'next mode))]
  205.           (add-source
  206.               (append2pth
  207.                      t
  208.                      (cond (error? la)(compile-write (1 exp) rbut cont)
  209.                            (null? la) (compile-glob-write (1 exp) rbut cont)
  210.                                       (compile-lex-write la) rbut cont))
  211.                (cons exp f-env))))
  212.   
  213. (define (compile-write v rbut cont)
  214.   (append2pth (synt-move "L" (data v) 'a0)
  215.               (cond (and (eq? cont 'return)(eq? rbut 'r0))
  216.                (synt-callo thunk:valvarset)
  217.               (appendpths (synt-call thunk:valvarset)
  218.                           (synt-move "L" 'r0 rbut)
  219.                           (compile-cont cont)))))
  220.  
  221. (define (compile-glob-write v rbut cont)
  222.   (appendpths (synt-move "L" (data v) 'a1)
  223.               (synt-move "L" 'r0 '(4 a1))
  224.               (synt-move "L" 'r0 rbut)
  225.               (compile-cont cont)))
  226.  
  227. (define (compile-lex-write la rbut cont)
  228.   (cond (zero? (0 la)) (synt-move "L" 'r0 `(,(+ 8 (* 4 (-1 la))) r2))
  229.         (appendpths (synt-move "L" '(4 r2) 'a1)
  230.                     (compile-frame-offset (1- (0 la)))
  231.                     (synt-move "L" 'r0 `(,(+ 8 (* 4 (-1 la))) a1))
  232.                     (synt-move "L" 'r0 rbut)
  233.                     (compile-cont cont))))
  234.  
  235.  
  236. ;••• begin •••
  237.  
  238. (define (begin? exp)
  239.   (and (cons? exp) (eq? (0 exp) 'begin)))
  240.  
  241. (define (compile-begin exp f-env rbut cont mode)
  242.    (add-source (comp-begin (-1 exp) f-env rbut cont mode)
  243.                (cons exp f-env)))
  244.  
  245. (define (comp-begin exps f-env rbut cont mode)
  246.    (cond (null? exps) (compile-constant '? f-env rbut cont mode)
  247.          (null? (-1 exps)) (compile-expression (0 exps) f-env rbut cont mode)
  248.          (let [(t (compile-expression (0 exps) f-env ƒ 'next mode))]
  249.                     (cond (memq? 'm (mod t))
  250.                         (preservepth 'r2
  251.                                       t
  252.                                       (comp-begin (-1 exps) f-env rbut cont mode))
  253.                         (comp-begin (-1 exps) f-env rbut cont mode)))))
  254.  
  255. ;••• Lambda •••
  256.  
  257. (define (lambda? exp)
  258.   (and (cons? exp) (eq? (0 exp) 'lambda)))
  259.  
  260. (define (compile-lambda exp f-env rbut cont mode)
  261.   (cond rbut
  262.         (let [(f-env (etend-env f-env (1 exp)))]
  263.           (add-source (appendpths (compile-closure-make (1 exp) (compile-corps (-1 exp) f-env) f-env)
  264.                                   (synt-move "L" 'a0 rbut)
  265.                                   (compile-cont cont))
  266.                      exp))
  267.          (compile-cont cont)))
  268.  
  269. (define (compile-corps exp f-env)
  270.   (let [(t  (comp-begin (-1 exp) f-env 'R0 'return default-mode))]
  271.         (add-source (append2pth (compile-make-env (0 exp) t) t) (-1 exp))))
  272.  
  273. (define (compile-make-env l t)
  274.    (let [(at (clos-typar l 0))]
  275.         (cond (zero? (-1 at))
  276.                 (cond (zero? (0 at)) (empty-pthunk)
  277.                   (appendpths
  278.                     (cond (memq? 'e (nec t))
  279.                       (appendpths
  280.                         (synt-move "L" `(# ,(+ 3 (* 2 (0 at)))) 'd0)
  281.                         (synt-call thunk:getablock)
  282.                         (synt-move "B" `(# ,type:env) '(-3 a0)))
  283.                       (appendpths
  284.                         (synt-move "L" `(# ,(+ 3 (0 at))) 'd0)
  285.                         (synt-call thunk:getablock)
  286.                         (synt-move "B" `(# ,type:senv) '(-3 a0))))
  287.                     (synt-move "L" 'R2 '(4 a0))
  288.                     (synt-move "L" 'a0 'r2)
  289.                     (synt-lea '(8 a0) 'a0)
  290.                     (compile-pop l (memq? 'e (nec t)) (0 at))))
  291.                 (appendpths
  292.                  (compile-cons-extra (0 at))
  293.                  (cond (memq? 'e (nec t))
  294.                   (appendpths
  295.                    (synt-move "L" `(# ,(+ 5 (* 2 (0 at)))) 'd0)
  296.                    (synt-call thunk:getablock)
  297.                    (synt-move "B" `(# ,type:env) '(-3 a0)))
  298.                   (appendpths
  299.                    (synt-move "L" `(# ,(+ 4 (0 at))) 'd0)
  300.                    (synt-call thunk:getablock)
  301.                    (synt-move "B" `(# ,type:senv) '(-3 a0))))
  302.                  (synt-move "L" 'R2 '(4 a0))
  303.                  (synt-move "L" 'a0 'r2)
  304.                  (synt-lea '(8 a0) 'a0)
  305.                  (compile-pop l (memq? 'e (nec t))(1+ (0 at)))))))
  306.  
  307.  
  308. (define (compile-pop l f n)
  309.   (appendpths (compile-pops n)
  310.                (cond f
  311.                  (compile-fill (reverse l))
  312.                  (empty-thunk))
  313.                (synt-lea '(-4 LP) 'LP)))
  314.  
  315. (define (compile-pops n)
  316.    (cond (zero? n) (empty-pthunk)
  317.          (append2pth (synt-move "L" '(- LP) '(a0 +))
  318.                         (compile-pops (1- n)))))
  319.  
  320. (define (compile-fill l)
  321.     (cond (null? l) (empty-pthunk)
  322.           (append2pth (synt-move "L" (data (0 l)) '(a0 +))
  323.                       (compile-fill (-1 l)))))
  324.  
  325. (define (compile-closure-make l t f-env)
  326.     (appendpths (synt-move "L" `(# 4) 'D0)
  327.                 (synt-call thunk:getablock)
  328.                 (synt-move "B" `(# ,(type type)) '(-3 a0))
  329.                 (synt-move "L" 'r2 '(4 a0))
  330.                 (synt-move "L" (data t) '(a0))
  331.                 (synt-move "L" `(# ,(+ (arite l)(* 65536 (tobit f-env l (str t))))) '(8 a0))))
  332.  
  333. (define (tobit f-env l s)
  334.   (letrec [((loop s b)
  335.              (cond (null? s) b
  336.                    (eq? (-1 (0 s)) f-env) (loop (-1 s) (findvar (0(0 s)) l 1))
  337.                    (loop (-1 l) b)))
  338.            ((findvar v l n)
  339.               (cond (null? l) 0
  340.                     (eq? (0 l) v) n
  341.                     (findvar v (-1 l) (+ n n))))]
  342.            (loop s 0)))
  343.  
  344. (define (compile-cons-extra ar)
  345.   (let [(loop (cree-label "loop"))
  346.         (after-loop (cree-label "after-loop"))]
  347.        (appendpths (synt-move "L" (data ()) 'r0)
  348.                    (synt-sub "W" `(# ,ar) 'd1)
  349.                    (synt-move "W" 'd1 '(- sp))
  350.                    (synt-beq after-loop)
  351.                    (synt-label loop)
  352.                    (synt-move "L" '(# 3) 'd0)
  353.                    (synt-call thunk:getablock)
  354.                    (synt-move "L" 'r0 '(4 a0))
  355.                    (synt-move "L" 'a0 'r0)
  356.                    (synt-move "L" '(- lp) '(r0))
  357.                    (synt-sub "W" '(# 1) '(sp))
  358.                    (synt-bpl loop)
  359.                    (synt-label after-loop)
  360.                    (synt-lea '(4 SP) 'Sp)
  361.                    (synt-move "L" 'r0 '(LP +)))))
  362.  
  363. (define (arite l)
  364.   (let [(at (clos-typar l 0))]
  365.        (coerce (bitor! (coerce (0 at) 3)
  366.                        (coerce (* 256 (-1 at)) 3)) 1)))
  367.     
  368. (define (clos-typar c a)
  369.    (cond (null? c) (cons a 0)
  370.          (ident? c) (cons a 1)
  371.          (and (cons? c)(ident? (0 c))) (clos-typar (-1 c) (1+ a))
  372.          (error '?:syntx-er c)))
  373.  
  374. ;••• Cond •••
  375. ;même si en Help, cond p.e vu comme une closure, on le compile ici (rapidité)
  376.  
  377. (define (cond? exp)
  378.   (and (cons? exp) (eq? (0 exp) 'cond)))
  379.  
  380. (define (compile-cond exp f-env rbut cont mode)
  381.   (cond (eq? cont 'next)
  382.          (let [(fin (cree-label "apres-cond"))]
  383.            (append2pth (compile-clauses (-1 exp) f-env rbut fin mode)
  384.                         (synt-label fin)))
  385.         (compile-clauses (-1 exp) f-env rbut cont mode)))
  386.  
  387. (define (compile-clauses exp f-env rbut cont mode)
  388.   (cond (null? exp) (compile-constant ƒ f-env rbut cont mode)
  389.         (null? (-1 exp)) (appendpths (compile-expression (0 exp) f-env 'r0 'next mode)
  390.                                       (comp-force 'r0)
  391.                                       (synt-move "L" 'r0 rbut)
  392.                                       (compile-cont cont))
  393.         (compile-clause
  394.           (0 exp)
  395.           (1 exp)
  396.           (-2 exp)
  397.           {(cree-label "cond-undef")}
  398.           f-env
  399.           rbut
  400.           cont
  401.           mode)))
  402.  
  403. (define (compile-clause test action others f-env rbut cont mode)
  404.   (cond (constante? test)
  405.           (cond (true? test)
  406.                  (compile-expression action f-env rbut cont mode)
  407.                  (compile-clauses others f-env rbut cont mode))
  408.        (let [(t-act (compile-expression action f-env rbut cont mode))
  409.              (t-tst (append2pth (compile-expression test f-env 'r0 'next mode)
  410.                                 (comp-force 'r0)))
  411.              (t-oth (compile-clauses others f-env rbut cont mode))
  412.              (l-fls (cree-label "cond-faux"))]
  413.             (preservepth 'r2
  414.                          t-tst
  415.                          (append2pth (compile-test "L" 'r0 (data ƒ) l-fls)
  416.                                      (undes2pth (append2pth t-act (synt-label l-fls))
  417.                                                 t-oth))))))
  418. (define (true? exp)
  419.    (neq? (valeur exp) ƒ))
  420.  
  421. (define (compile-test s m1 m2 l)
  422.    (append2pth (synt-cmp s m1 m2)
  423.                (synt-beq l)))
  424.  
  425. ;••• bindings •••
  426.  
  427. (define (bindings? exp)
  428.   (cond (cons? exp) (eq? (0 exp) 'bindings)))
  429.  
  430. (define (compile-bindings exp f-env rbut cont mode)
  431.     (add-source
  432.       (cond rbut
  433.         (appendpths (synt-move "L" 'r2 rbut)
  434.                     (add-info '(e)()())
  435.                     (compile-cont cont))
  436.         (compile-cont cont))
  437.                 (cons exp f-env)))
  438.  
  439. ;••• Macros •••
  440.  
  441. (define (macro-exp? exp)
  442.   (cond (cons? exp) (macro? (0 exp))))
  443.  
  444. (define (compile-macro exp f-env rbut cont mode)
  445.   (add-source (compile-expression (expand exp) f-env rbut cont mode) (cons exp f-env)))
  446.  
  447. ;••• NoMemo •••
  448.  
  449. (define (nomemo? exp)
  450.   (and (cons? exp) (eq? (0 exp) 'nomemo)))
  451.  
  452. (define (compile-nomemo exp f-env rbut cont mode)
  453.  (add-source
  454.   (cond (constante? exp)(compile-constant exp f-env rbut cont mode)
  455.         (quotee? exp)(compile-quotee exp f-env rbut cont mode)
  456.         (let [(t (compile-expression (cons 'begin (-1 exp)) f-env rbut cont mode))]
  457.              (appendpths (synt-move "L" 'D7 '(- sp))
  458.                          (synt-bset 31 'D7)
  459.                          (compile-susp t rbut cont)
  460.                          (synt-move "L" '(sp +) 'D7)))) (cons exp f-env)))
  461.  
  462. ;••• warn •••
  463.      
  464. (define (warn? exp)
  465.   (and (cons? exp) (eq? (0 exp) 'warn)))
  466.  
  467. (define (compile-warn exp f-env rbut cont mode)
  468.  (add-source
  469.   (appendpths (synt-move "L" 'D7 '(- sp))
  470.               (synt-move "B" (cond (eq? (1 exp) ƒ)  '(# 0)
  471.                                    (eq? (1 exp) ()) '(# -1)
  472.                                    '(# 1)) 'D7)
  473.               (compile-expression (cons 'begin (-1 exp)) f-env rbut cont mode)
  474.               (synt-move "L" '(sp +) 'd7)) (cons exp f-env)))
  475.  
  476. ;••• Step •••
  477.      
  478. (define (step-call? exp)
  479.   (and (cons? exp) (eq? (0 exp) 'step)))
  480.  
  481. (define (compile-step exp f-env rbut cont mode)
  482.   )
  483.  
  484. ;••• let •••
  485.      
  486. (define (let? exp)
  487.   (and (cons? exp) (eq? (0 exp) 'let)))
  488.  
  489. (define (compile-let exp f-env rbut cont mode)
  490.   )
  491.  
  492. ;••• Letrec •••
  493.      
  494. (define (rec? exp)
  495.   (and (cons? exp) (eq? (0 exp) 'letrec)))
  496.  
  497. (define (compile-rec exp f-env rbut cont mode)
  498.   )
  499.  
  500. ;••• Application sans args •••
  501.  
  502. (define (ss-args? exp)
  503.   (and (cons? exp) (null? (-1 exp))))
  504.  
  505. (define (compile-ss-args exp f-env rbut cont mode)
  506.   (add-source
  507.    (cond {(lambda? (0 exp)) (compile-let (lambda2let exp) f-env rbut cont mode)}
  508.          (constante? (0 exp)) (compile-opt-ss-args  (valeur (0 exp)) f-env rbut cont mode)
  509.          (quotee? (0 exp)) (compile-opt-ss-args (1 (0 exp)) f-env rbut cont mode)
  510.          (compile-noopt-ss-arg exp f-env rbut cont mode))
  511.   exp))
  512.  
  513. (define (compile-noopt-ss-arg exp f-env rbut cont mode)
  514.   (appendpths (compile-expression (0 exp) f-env 'r0 'next mode)
  515.               (synt-move "L" 'r0 '(LP +))
  516.               (synt-move "L" 'lp '(- SP))
  517.               (synt-move "W" '(# 0) 'd1)
  518.               (cond (and (eq? cont 'return)(eq? rbut 'r0))
  519.                      (synt-callo thunk:applyit)
  520.                      (appendpths (synt-call thunk:applyit)
  521.                                  (synt-move "L" 'r0 rbut)
  522.                                  (compile-cont cont)))))
  523.  
  524. (define (compile-opt-ss-args f f-env rbut cont mode)
  525.   (cond (=? (type f) 1) (error '?:few-args f)
  526.         (closure? f) (letrec [(at (getaritype f))
  527.                               (type (modulo at 256))
  528.                               (ari  (/ at 256))]
  529.                           (cond (<>? ari 0) (error '?:few-args f)
  530.                                 (=? type 0) (compile-procn-call-ss f cont rbut)
  531.                                 (compile-nproc-call-ss f cont rbut)))
  532.         (error '? (list "ne sais pas compiler1" f))))
  533.  
  534. (define (compile-procn-call-ss f cont rbut)
  535.   (appendpths (synt-move "L" (data f) 'a0)
  536.               (synt-move "L" 'a0 '(LP +))
  537.               (synt-move "L" '(4 a0) 'r2)
  538.               (synt-move "L" '(a0) 'a0)
  539.               (cond (and (eq? cont 'return)
  540.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  541.                     (appendpths (synt-jsr '(8 a0))
  542.                                 (synt-move "L" 'r0 rbut)
  543.                                 (compile-cont cont)))))
  544.  
  545.  
  546. (define (compile-nproc-call-ss f cont rbut)
  547.   (appendpths (synt-move "L" (data f) 'a0)
  548.               (synt-move "L" 'a0 '(LP +))
  549.               (synt-move "L" (data '()) '(LP +))
  550.               (synt-move "W" '(# 0) 'd1)
  551.               (synt-move "L" '(4 a0) 'r2)
  552.               (synt-move "L" '(a0) 'a0)
  553.               (cond (and (eq? cont 'return)
  554.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  555.                     (appendpths (synt-jsr '(8 a0))
  556.                                 (synt-move "L" 'r0 rbut)
  557.                                 (compile-cont cont)))))
  558.                   
  559. ;••• Application avec args •••
  560.  
  561. (define (application? exp)
  562.   (cons? exp))
  563.  
  564. (define (compile-application exp f-env rbut cont mode)
  565.   (add-source
  566.    (cond {(lambda? (0 exp)) (compile-let (lambda2let exp) f-env rbut cont mode)}
  567.          (constante? (0 exp)) (compile-opt-app (valeur (0 exp)) (-1 exp) f-env rbut cont mode)
  568.          (quotee? (0 exp)) (compile-opt-app (1 (0 exp))(-1 exp) f-env rbut cont mode)
  569.          (compile-noopt-app exp f-env rbut cont mode))
  570.    exp))
  571.  
  572. (define (compile-noopt-app exp f-env rbut cont mode)
  573.   (append2pth
  574.     (preservepth 'r2
  575.                  (compile-expression (0 exp) f-env 'r0 'next mode)
  576.                  (appendpths (synt-move "L" 'r0 '(LP +))
  577.                              (synt-move "L" 'LP '(- SP))
  578.                              (push-thunks (-1 exp) f-env mode)
  579.                              (synt-move "W" (list '# (length (-1 exp))) 'd1)))
  580.     (cond (and (eq? cont 'return)(eq? rbut 'r0))
  581.            (synt-callo thunk:susp&apply)
  582.            (appendpths (synt-call thunk:susp&apply)
  583.                        (synt-move "L" 'r0 rbut)
  584.                        (compile-cont cont)))))
  585.   
  586. (define (push-thunks args f-env mode)
  587.   (cond (null? args) (empty-pthunk)
  588.         (append2pth (synt-move "L"
  589.                                (data (compile-expression (0 args) f-env 'r0 'return mode))
  590.                                '(LP +))
  591.                     (push-thunks (-1 args) f-env mode))))
  592.   
  593. (define (compile-opt-app f arg f-env rbut cont mode)
  594.   (cond (=? (type f) 1) (compile-select f arg f-env rbut cont mode)
  595.         (closure? f) (compile-clos-app f arg f-env rbut cont mode)
  596.         (error '? (list "sais pas compiler2" (cons f arg)))))
  597.  
  598. (define (compile-select f arg f-env rbut cont mode)
  599.   (error '? (list "sais pas compiler2" (cons f arg))))
  600.   
  601. (define (compile-clos-app f arg f-env rbut cont mode)
  602.   (letrec [(at (getaritype f))
  603.            (type (modulo at 256))
  604.            (ari  (/ at 256))
  605.            (narg (length arg))]
  606.           (cond (=? type 0) (cond (=? narg ari) (compile-procn-call f arg cont rbut f-env mode)
  607.                                   (>? narg ari) (error '?:too-args (cons f arg))
  608.                                   (<? narg ari) (error '?:few-args (cons f arg)))
  609.                 (>? narg ari)(compile-nproc-call f arg cont rbut f-env mode)
  610.                 (=? narg ari)(compile-nproc-call f arg cont rbut f-env mode)
  611.                 (error? '?:few-args (cons f arg)))))
  612.  
  613. (define (compile-procn-call f args cont rbut f-env mode)
  614.   (appendpths (synt-move "L" (data f) '(lp +))
  615.               (push-args2 (getstrict f) args f-env mode)
  616.               (synt-move "L" (data f) 'a0)
  617.               (synt-move "L" '(4 a0) 'r2)
  618.               (synt-move "L" '(a0) 'a0)
  619.               (cond (and (eq? cont 'return)
  620.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  621.                     (appendpths (synt-jsr '(8 a0))
  622.                                 (synt-move "L" 'r0 rbut)
  623.                                 (compile-cont cont)))))
  624.  
  625. (define (push-args2 s args f-env mode)
  626.   (letrec [((loop s arg n)
  627.               (cond (null? arg)
  628.                      (empty-pthunk)
  629.                     (n s)
  630.                     (preservepth 'r2
  631.                                   (compile-expression (0 arg) f-env '(lp +) 'next mode)
  632.                                   (append2pth
  633.                                      (cond (variable? (0 arg)) 
  634.                                             (add-strict (getlex (0 arg) f-env))
  635.                                             (empty-pthunk))
  636.                                   (loop s (-1 arg) (cond (=? n 15) 15 (1+ n)))))
  637.                     (appendpths (compile-chilled (0 arg) f-env '(lp +) 'next mode)
  638.                                 (loop s (-1 arg) (cond (=? n 15) 15 (1+ n))))))]
  639.           (loop s args 0)))
  640.  
  641. (define (compile-nproc-call f args cont rbut f-env mode)
  642.   (appendpths (synt-move "L" (data f) '(lp +))
  643.               (push-args2 (getstrict f) args f-env mode)
  644.               (synt-move "L" (data f) 'a0)
  645.               (synt-move "L" '(4 a0) 'r2)
  646.               (synt-move "L" '(a0) 'a0)
  647.               (synt-move "W" `(# ,(length args)) 'd1)
  648.               (cond (and (eq? cont 'return)
  649.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  650.                     (appendpths (synt-jsr '(8 a0))
  651.                                 (synt-move "L" 'r0 rbut)
  652.                                 (compile-cont cont)))))
  653.  
  654. ;••• Paresse •••
  655.  
  656. (define (compile-chilled exp f-env rbut cont mode)
  657.   (cond (constante? exp)(compile-constant exp f-env rbut cont mode)
  658.         (quotee? exp)(compile-quotee exp f-env rbut cont mode)
  659.         (let [(t (compile-expression exp f-env rbut 'return mode))]
  660.                  (compile-susp t rbut cont))))
  661.  
  662. (define (compile-susp t rbut cont)
  663.   (appendpths (synt-move "L" '(# 4) 'd0)
  664.               (synt-call thunk:getablock)
  665.               (synt-move "W" `(# ,(+ 1024 type:susp)) '(-4 a0))
  666.               (synt-move "L" (data t) '(a0))
  667.               (synt-move "L" 'r2 '(4 a0))
  668.               (synt-move "L" 'D7 '(8 a0))
  669.               (synt-move "L" 'a0 rbut)
  670.               (compile-cont cont)))
  671.  
  672. ;••• labels •••
  673.  
  674. ;un label sera le cons de 'label et de la chaîne
  675. ;c'est l'adresse du cons formé qui indiquera le label
  676.  
  677. (define (cree-label s)
  678.   (cons 'label s))
  679.  
  680. ;••• Xrefs •••
  681.  
  682. ;on peut xrefer une donnée (data)
  683.  
  684. (define (data o)
  685.         (list 'data o))
  686.  
  687. (define (data? u)
  688.   (and (cons? u)
  689.        (eq? (0 u) 'data)))
  690.  
  691. ;••• TYPES •••
  692.  
  693. (define type:env 16)
  694. (define type:senv 17)
  695. (define type:susp 20)
  696.  
  697. ;••• Divers •••
  698.  
  699. (define (union-set e f)
  700.     (cond (null? e) f
  701.           (memq? (0 e) f)(union-set (-1 e) f)
  702.           (cons (0 e) (union-set (-1 e) f))))
  703.  
  704. (define (union-tout l)
  705.     (cond (null? l) ()
  706.         (union-set (0 l) (union-tout (-1 l)))))
  707.  
  708. (define (differ-set e f)
  709.     (cond (null? e) '()
  710.           (memq? (0 e) f)(differ-set (-1 e) f)
  711.           (cons (0 e) (differ-set (-1 e) f))))
  712.  
  713. (define (inter-set e f)
  714.     (cond (null? e) '()
  715.           (memq? (0 e) f)(cons e (inter-set (-1 e) f))
  716.           (inter-set (-1 e) f)))
  717.  
  718. ;••• Environnements •••
  719. ;nous représenterons le "futur env" par une cellule
  720. ;1er élém:next frame ou () ou ?
  721. ;suite:les variables
  722.  
  723. (define (etend-env env lv)
  724.   (apply cell (cons env (reverse lv))))
  725.  
  726. ;••• calcule le Frame Offset et le Var Offset…dans l'environnement futur •••
  727.  
  728. (define (calcule-lex-address var f-env)
  729.     (CalcLex var f-env 0 0))
  730.  
  731. (define (CalcLex var f-env fo vo)
  732.     (cond (null? f-env) ()
  733.           (eq? f-env '?) '?
  734.           (=? (blength f-env) (+ 2 vo)) (CalcLex var (0 f-env) (1+ fo) 0)
  735.           (eq? ((1+ vo) f-env) var) (cons fo vo)
  736.           (CalcLex var f-env fo (1+ vo))))
  737.  
  738. (define (getlex var f-env)
  739.    (letrec [((getenv f-env vo)
  740.                (cond (null? f-env) ()
  741.                      (eq? f-env '?) '?
  742.                      (=? (blength f-env) (+ 2 vo)) (getenv (0 f-env) 0)
  743.                      (eq? ((1+ vo) f-env) var) f-env
  744.                      (getenv f-env (1+ vo))))]
  745.            (cons var (getenv f-env 0))))